{*
  Object Pascal simple graphics manipulation routines
  @Author  Maciej Zagozda (1998-2008)
  @Licence Microsoft Reciprocal License (Ms-RL)
  @Website http://www.codeplex.com/intelitechdelphirtns/
  @Version 2008/04/20 Added documentation support
}

unit GraphicsRoutines;

interface

uses
  Windows,
  Classes,
  Dialogs,
  Graphics,
  Messages,
  Printers,
  SysUtils;

type
  PPalEntriesArray = ^TPalEntriesArray;
  TPalEntriesArray = array[0..0] of TPaletteEntry;

function AddPoints( const PointA, PointB: TPoint ): TPoint;
function BitmapToDib(DestDc: hdc; x: word; y: word; Width : word; Height : word; bm : TBitmap ): Boolean;
function ColorToHTML( colrColor: TColor ): AnsiString;
function CircleContainsPoint( Center, Point: TPoint; Radius: Integer ): Boolean;
function ClearCanvas( Canvas: TCanvas; Color: TColor ): Boolean;
function CreateFormThumbnail(frmDefault: TForm; imgThumbnail: TImage; const intMaxWidth: Integer; const intMaxWidth: Integer): Boolean;
function DrawBezierLine( Canvas: TCanvas; Points: array of TPoint ): Boolean;
function DrawBezierPolygon( Canvas: TCanvas; Points: array of TPoint ): Boolean;
function DrawCircle( Canvas: TCanvas; Center: TPoint; Radius: Integer ): Boolean;
function DrawNormalLine( Canvas: TCanvas; Point1, Point2: TPoint ): Boolean;
function GetLightenColor( colrColor: TColor ): TColor;
function SubtractPoints( const PointA, PointB: TPoint ): TPoint;
function SquareContainsText( canvCanvas: TCanvas; rectRect: TRect; strnText: AnsiString ): Boolean;
//function SquareContainsText( canvCanvas: TCanvas; rectRect: TRect; strnText: AnsiString ): Boolean;

implementation

uses
  MessageRoutines;

function AddPoints( const PointA, PointB: TPoint ): TPoint;
begin
  with Result do
  begin
    X := PointA.X + PointB.X;
    Y := PointA.Y + PointB.Y;
  end;//with
end;

//_____________________________________________________________________________

function BitmapToDib(DestDc: hdc; x: word; y: word; Width : word; Height : word; bm : TBitmap ): Boolean;
var
  OriginalWidth :LongInt;
  dc : hdc;
  IsPaletteDevice : bool;
  IsDestPaletteDevice : bool;
  BitmapInfoSize : integer;
  lpBitmapInfo : PBitmapInfo;
  hBm : hBitmap;
  hPal : hPalette;
  OldPal : hPalette;
  hBits : THandle;
  pBits : pointer;
  lPPalEntriesArray : PPalEntriesArray;
  NumPalEntries : integer;
  i : integer;
begin
  {$IFOPT R+}
    {$DEFINE CKRANGE}
    {$R-}
  {$ENDIF}
  OriginalWidth := bm.Width;
  dc := GetDc(0);
  IsPaletteDevice := GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
  dc := ReleaseDc(0, dc);

  if IsPaletteDevice then
    BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
  else
    BitmapInfoSize := sizeof(TBitmapInfo);

  GetMem(lpBitmapInfo, BitmapInfoSize);
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
  lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;

  if IsPaletteDevice then
    lpBitmapInfo^.bmiHeader.biBitCount := 8
   else
    lpBitmapInfo^.bmiHeader.biBitCount := 24;

  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage :=    ((lpBitmapInfo^.bmiHeader.biWidth * longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *  lpBitmapInfo^.bmiHeader.biHeight;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;

  if IsPaletteDevice then
  begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 256;
    lpBitmapInfo^.bmiHeader.biClrImportant := 256;
  end
  else
  begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 0;
    lpBitmapInfo^.bmiHeader.biClrImportant := 0;
  end;//if

  hBm := bm.ReleaseHandle;
  hPal := bm.ReleasePalette;

  dc := GetDc(0);

  if IsPaletteDevice then
  begin
    OldPal := SelectPalette(dc, hPal, TRUE);
    RealizePalette(dc);
  end;//if

  GetDiBits(dc, hBm, 0, lpBitmapInfo^.bmiHeader.biHeight, nil, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS );
  hBits := GlobalAlloc(GMEM_MOVEABLE, lpBitmapInfo^.bmiHeader.biSizeImage);
  pBits := GlobalLock(hBits);

  GetDiBits(dc, hBm, 0, lpBitmapInfo^.bmiHeader.biHeight, pBits, TBitmapInfo(lpBitmapInfo^), DIB_RGB_COLORS );
  if IsPaletteDevice then
  begin
    GetMem( lPPalEntriesArray, sizeof(TPaletteEntry) * 256 );
    {$IFDEF VER100}
      NumPalEntries := GetPaletteEntries(hPal, 0, 256, lPPalEntriesArray^);
    {$ELSE}
      NumPalEntries := GetSystemPaletteEntries(dc, 0, 256, lPPalEntriesArray^);
    {$ENDIF}

    for i := 0 to (NumPalEntries - 1) do begin
      lpBitmapInfo^.bmiColors[i].rgbRed := lPPalEntriesArray^[i].peRed;
      lpBitmapInfo^.bmiColors[i].rgbGreen := lPPalEntriesArray^[i].peGreen;
      lpBitmapInfo^.bmiColors[i].rgbBlue := lPPalEntriesArray^[i].peBlue;
    end;

    FreeMem( lPPalEntriesArray, sizeof(TPaletteEntry) * 256 );
  end;

  if IsPaletteDevice then
  begin
    SelectPalette(dc, OldPal, TRUE);
    RealizePalette(dc);
  end;

  dc := ReleaseDc(0, dc);
  IsDestPaletteDevice := GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
  if IsPaletteDevice then
  begin
    OldPal := SelectPalette(DestDc, hPal, TRUE);
    RealizePalette(DestDc);
  end;

  StretchDiBits(DestDc, x, y, Width, Height, 0, 0, OriginalWidth, lpBitmapInfo^.bmiHeader.biHeight, pBits, lpBitmapInfo^, DIB_RGB_COLORS, SrcCopy );
  if IsDestPaletteDevice then
  begin
    SelectPalette(DestDc, OldPal, TRUE);
    RealizePalette(DestDc);
  end;

  GlobalUnLock(hBits);
  GlobalFree(hBits);

  FreeMem(lpBitmapInfo, BitmapInfoSize);
  bm.Handle := hBm;
  bm.Palette := hPal;

  {$IFDEF CKRANGE}
   {$UNDEF CKRANGE}
   {$R+}
  {$ENDIF}

  Result := True;
end;

//_____________________________________________________________________________

function ColorToHTML( colrColor: TColor ): AnsiString;
var
  intgR, intgG, intgB: Integer;
  strnResult: AnsiString;
begin
  intgR := GetRValue( colrColor );
  intgG := GetGValue( colrColor );
  intgB := GetBValue( colrColor );

  strnResult := '#';
  strnResult := strnResult + IntToHex( intgR, 2 );
  strnResult := strnResult + IntToHex( intgG, 2 );
  strnResult := strnResult + IntToHex( intgB, 2 );

  Result := strnResult;

end;


//_____________________________________________________________________________

function CircleContainsPoint( Center, Point: TPoint; Radius: Integer ): Boolean;
var
  Line1, Line2, Line3: Double;
begin
   Line1 := Abs( Point.X - Center.X );
   Line2 := Abs( Point.Y - Center.Y );
   Line3 := Sqrt(( Line1 * Line1 ) + ( Line2 * Line2 ));
   Result := Radius >= Line3;
end;

//_____________________________________________________________________________

function CheckBezierLine( Points: array of TPoint ): Integer;
begin
  Result := High( Points ) - Low( Points ) + 1;
  if ( Result <= 1 ) or (( Result - 1 ) mod 3 <> 0 ) then
  begin
    raise Exception.Create( 'Not enough bezier points specified.' );
  end;//if
end;

//_____________________________________________________________________________

{
function ClearCanvas( Canvas: TCanvas ): Boolean;
begin
  PatBlt( Canvas.Handle, 0, 0, ClientWidth, Form1.ClientHeight, WHITENESS);
end;
}
function ClearCanvas( Canvas: TCanvas; Color: TColor ): Boolean;
begin
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect( ClipRect );
  end;//with
end;

{*------------------------------------------------------------------------------
  Creates a thumbnail of a client area of a form using proportional
  resizing according to specified maximum width and height parameters.
  Does not employ any anti-aliasing techniques.

  @param frmDefault - Form to be captured
  @param imgThumbnail - Image to hold thumbnail
  @param intgMaxWidth - maximum width of a resulting thumbnail
  @param intgMaxHeight - maximum height of a resulting thumbnail
  @return True on succesfull creation, false otherwise
  @version 1.0
-------------------------------------------------------------------------------}

function CreateFormThumbnail(frmDefault: TForm; imgThumbnail: TImage; const intMaxWidth: Integer; const intMaxWidth: Integer): Boolean;
var
  btmpThumbnail: TBitmap;
  rectThumbnail: TRect;
begin
  btmpThumbnail := frmDefault.GetFormImage;
  try
    try
      rectThumbnail.Left := 0;
      rectThumbnail.Top := 0;

      if btmpThumbnail.Width > btmpThumbnail.Height then
      begin
        rectThumbnail.Right := intgMaxWidth;
        rectThumbnail.Bottom := (intgMaxWidth * btmpThumbnail.Height) div btmpThumbnail.Width;
      end
      else
      begin
        rectThumbnail.Bottom := intgMaxHeight;
        rectThumbnail.Right := (intgMaxHeight * btmpThumbnail.Width) div btmpThumbnail.Height;
      end;

      btmpThumbnail.Canvas.StretchDraw(rectTHumbnail, btmpThumbnail) ;

      btmpThumbnail.Width := rectThumbnail.Right;
      btmpThumbnail.Height := rectThumbnail.Bottom;

      imgThumbnail.Picture.Assign(btmpThumbnail) ;
      Result := True;
    except
      Result := False;
    end;//try
  finally
    btmpThumbnail.Free;
  end;
end;

//_____________________________________________________________________________

function DrawBezierLine( Canvas: TCanvas; Points: array of TPoint ): Boolean;
var
  intgCount: Integer;
begin
  Result := True;

  intgCount := CheckBezierLine( Points );
  if not PolyBezier( Canvas.Handle, Points, intgCount ) then
  begin
    Result := False;
  end;//if
end;

//_____________________________________________________________________________

function DrawBezierPolygon( Canvas: TCanvas; Points: array of TPoint ): Boolean;
var
  intgCount: Integer;
begin

  Result := True;

  intgCount := CheckBezierLine( Points );
  SetLastError(0);

    if not BeginPath( Canvas.Handle ) then
    begin
      Result := False;
    end;//if
    try
      if not PolyBezier( Canvas.Handle, Points, intgCount ) then
      begin
        Result := False;
      end;//if

      if not CloseFigure( Canvas.Handle ) then
      begin
        Result := False;
      end;//if
    finally
      if not EndPath( Canvas.Handle ) then
      begin
        Result := False;
      end;//if
    end;//try

    Canvas.Brush.Color := clRed;

    if not StrokeAndFillPath( Canvas.Handle ) then
    begin
      Result := False;
    end;//if
end;

//_____________________________________________________________________________

function DrawCircle( Canvas: TCanvas; Center: TPoint; Radius: Integer ): Boolean;
begin
  Result := True;

  try
    with Canvas do
    begin
      Ellipse( Center.X - Radius, Center.Y - Radius, Center.X + Radius, Center.Y + Radius );
    end;//with
  except
    Result := False;
  end;//try
end;

//_____________________________________________________________________________

function DrawNormalLine( Canvas: TCanvas; Point1, Point2: TPoint ): Boolean;
begin
  Result := True;

  try
    with Canvas do
    begin
      PenPos := Point1;
      LineTo( Point2.X, Point2.Y );
    end;//with
  except
    Result := False;
  end;//try
end;

//_____________________________________________________________________________

function GetLightenColor( colrColor: TColor ): TColor;
var
  byteR, byteG, byteB: Integer;
begin
  byteR := GetRValue( ColorToRGB( colrColor ));
  Inc( byteR, 20 );
  if byteR > 255 then byteR := 255;

  byteG := GetGValue( ColorToRGB( colrColor ));
  Inc( byteG, 20 );
  if byteG > 255 then byteG := 255;

  byteB := GetBValue( ColorToRGB( colrColor ));
  Inc( byteB, 20 );
  if byteB > 255 then byteB := 255;

  Result := RGB( byteR, byteG, byteB );

end;

//_____________________________________________________________________________

function SubtractPoints( const PointA, PointB: TPoint ): TPoint;
begin
  with Result do
  begin
    X := PointA.X - PointB.X;
    Y := PointA.Y - PointB.Y;
  end;//with
end;

//_____________________________________________________________________________

function SquareContainsPoint ( pontSquareCenter: TPoint; intgSquareHalfSize: Integer; pontTest: TPoint): Boolean;
begin
   Result := (pontTest.X >= pontSquareCenter.X - intgSquareHalfSize) and
             (pontTest.X <= pontSquareCenter.X + intgSquareHalfSize) and
             (pontTest.Y >= pontSquareCenter.Y - intgSquareHalfSize) and
             (pontTest.Y <= pontSquareCenter.Y + intgSquareHalfSize);
end;

//_____________________________________________________________________________

function SquareContainsText( canvCanvas: TCanvas; rectRect: TRect; strnText: AnsiString ): Boolean;
begin
  with canvCanvas do
  begin
    if(( TextExtent( strnText ).CX ) > ( rectRect.Right - rectRect.Left )) or
      (( TextExtent( strnText ).CY ) > ( rectRect.Top - rectRect.Bottom )) then
    begin
      Result := False;
    end
    else
    begin
      Result := True;
    end;//if
  end;//with
end;
                          
end.
